perm filename NEWADD[RLL,DBL] blob
sn#652292 filedate 1982-04-07 generic text, type T, neo UTF8
(FILECREATED "11-Mar-82 18:32:50" <MANCOM.RLL>NEWADDITIONS..3 12482
changes to: KB-SUMMARY InverseLIL ComplexVV SFVerifyRR DTVerifyRR LOVerifyRR
FigureMSF DI-Print P-PLST SELECTIVE-UNADVISE
previous date: "10-Mar-82 17:23:41" <MANCOM.RLL>NEWADDITIONS..1)
(PRETTYCOMPRINT NEWADDITIONSCOMS)
(RPAQQ NEWADDITIONSCOMS ((FNS * NEWADDITIONSFNS)
(VARS * NEWADDITIONSVARS)))
(RPAQQ NEWADDITIONSFNS (CheckWhy ComplexVV DI-Print DTVerifyRR DefaultInvalidateUnitFn
FigureMSF InverseLIL KB-SUMMARY LOVerifyRR P-PLST
SELECTIVE-UNADVISE SFVerifyRR UpdateDepend))
(DEFINEQ
(CheckWhy
[LAMBDA (y)
(* edited: "10-Mar-82 17:04")
(DECLARE (SPECVARS y))
(PROG (unexplained)
(DECLARE (LOCALVARS unexplained))
(* The APPEND is used as I will be DESTRUCTIVELY changing y.)
(RETURN (COND
([SETQ unexplained
(SOME y (FUNCTION (LAMBDA (term)
(DECLARE (LOCALVARS term))
(PROG (hold)
(DECLARE (LOCALVARS hold)
(SPECVARS y)
(GLOBALVARS ValidWhyValues))
(RETURN (COND
[(LISTP term)
(NOT (FMEMB (CAR term)
(QUOTE (From]
((FMEMB term ValidWhyValues)
NIL)
((SETQ hold (ConvertWhy term))
(SETQ y (UNION hold (REMOVE term y)))
NIL)
(T T]
(Warning "why passed" " with value: " y "!" " (" (CAR unexplained)
")."))
(T y])
(ComplexVV
[LAMBDA (un sl old modif why)
(* edited: "11-Mar-82 15:09" Changed GetValue's to GetField's.)
(DECLARE (LOCALVARS un sl old modif why))
(PROG (dt sltvfr vfrtype new xtra)
(DECLARE (LOCALVARS dt sltvfr vfrtype new xtra))
(SELECTQ (CAR modif)
((Delete1 DeleteN)
(RETURN modif))
(NewVal (SETQ new (CDR modif))
[SETQ sltvfr (GetField un sl (QUOTE VerifyAll)
(QUOTE (SAFESLOT]
(SETQ xtra NIL)
(SETQ vfrtype (QUOTE FnForVerifyingAll)))
((Add1 AddN)
(SETQ new (CDR modif))
[SETQ sltvfr (GetField un sl (QUOTE VerifyElement)
(QUOTE (SAFESLOT]
[SETQ xtra (COND
((EQ (CAR modif)
(QUOTE AddN))
(LIST (QUOTE VerifyN)))
(T (LIST (QUOTE Verify1]
(SETQ vfrtype (QUOTE FnForVerifyingElement)))
((Subst1 SubstN)
(SETQ new (CADR modif))
[SETQ sltvfr (GetField un sl (QUOTE VerifyElement)
(QUOTE (SAFESLOT]
[SETQ xtra (COND
((EQ (CAR modif)
(QUOTE SubstN))
(LIST (QUOTE VerifyN)))
(T (LIST (QUOTE Verify1]
(SETQ vfrtype (QUOTE FnForVerifyingElement)))
(Warning "Wrong argument given for modify flag: " modif))
(RETURN (COND
((MustComputep new)
modif)
((NOT (IsOk sltvfr))
(Warning "Unable to verify values are correct" " for slot " sl
" in unit "
un))
((FormattedValuep old)
(APPLY* (GetValue (ValueFormat old)
vfrtype
(QUOTE (SAFESLOT)))
un sl new sltvfr xtra modif))
((FormattedValuep new)
(APPLY* (GetValue (ValueFormat new)
vfrtype
(QUOTE (SAFESLOT)))
un sl new sltvfr xtra modif))
(T (APPLY* sltvfr un sl new sltvfr xtra modif])
(DI-Print
[LAMBDA (F S I POS Char1 Char2 done)
(* edited: "11-Mar-82 15:35" Format fix.)
(DECLARE (LOCALVARS F S I POS Char1 Char2 done))
(COND
((MEMBER F done)
(SPACES POS TTY)
(WRITELNTTY Char1 "{" F "⎇" Char2)
NIL)
(T (SPACES POS TTY)
(WRITETTY Char1 F Char2)
[COND
((FMEMB (QUOTE D)
S)
(PROG [(Descr (GetValue F (QUOTE Descr)
(QUOTE (SAFESLOT]
(AND (IsOk Descr)
(printout TTY .SP 2 .PPV Descr]
(WRITELNTTY)
(CONS F done])
(DTVerifyRR
[LAMBDA (NewSpec OldSpec)
(* edited: "11-Mar-82 15:23" Verify Range Restrictions for Data
Types.)
(AND (OR [FMEMB (CAR NewSpec)
(GetValue (CAR OldSpec)
(QUOTE SuperDT*)
(QUOTE (SAFESLOT]
(Warning "Incompatible Datatype Specs " NewSpec " and " OldSpec "."))
(OR (EQ (LENGTH NewSpec)
(LENGTH OldSpec))
(Warning "Unequal length Datatype Specs " NewSpec " and " OldSpec "."))
(APPLY (FUNCTION AND)
(MAP2CAR (CDR NewSpec)
(CDR OldSpec)
(FUNCTION (LAMBDA (NewClause OldClause)
(DECLARE (LOCALVARS NewClause OldClause))
(APPLY* (COND
[(IsOk (GetValue (CAR NewClause)
(QUOTE
FnForVerifyingRangeRestriction)
(QUOTE (SAFESLOT]
(T (Warning (CAR NewClause)
" has no FnForVerifyingRangeRestriction.")
(FUNCTION NILL)))
NewClause OldClause])
(DefaultInvalidateUnitFn
[LAMBDA (un sl dueTo why)
(* edited: "10-Mar-82 17:04")
(DECLARE (LOCALVARS un sl why))
(DefaultAfterPutValue un sl RecomputeMe (CONS (QUOTE OldVal)
RecomputeMe)
(INSERT why (QUOTE +DEPENDENCIES])
(FigureMSF
[LAMBDA (dom)
(* edited: "11-Mar-82 15:33" Bug Fix.)
(DECLARE (LOCALVARS dom))
(SELECTQ (CAR dom)
[*P (ListIfOk (GetValue (CADR dom)
(QUOTE TypicalExample)
(QUOTE (SAFESLOT]
[L-AND (CAR (MAPCONC (CDR dom)
(FUNCTION FigureMSF]
(L-OR (MAPCONC (CDR dom)
(FUNCTION FigureMSF)))
NIL])
(InverseLIL
[LAMBDA (un new modif why)
(* edited: "11-Mar-82 14:53" Modified to remove unconditional
precautionary Warning.)
(DECLARE (LOCALVARS un new modif why))
(COND
((NEQ (CAR modif)
(QUOTE OldVal))
(Warning "In " (QUOTE InverseLIL)
"."))
(T (UA-PUTPROP (CAR new)
(CADR new)
(PointAt un])
(KB-SUMMARY
[LAMBDA (KBName FileName)
(* edited: "18-Jan-82 17:58")
(UF-SUMMARY [CAR (SOME UF.NETWORKS (FUNCTION (LAMBDA (elt)
(STRPOS (U-CASE KBName)
(U-CASE elt]
NIL FileName (FUNCTION (LAMBDA (un)
(WRITELN "UNIT: " un)
(P-PLST (UA-GET un)
FileName])
(LOVerifyRR
[LAMBDA (NewSpec OldSpec)
(* edited: "11-Mar-82 15:28" First try at Range Restriction
verification for Logical Ops.)
(Warning "Can't yet hack Range Specs with LogicalOps like " NewSpec " and " OldSpec
"."])
(P-PLST
[LAMBDA (plst file)
(* edited: "11-Mar-82 17:06")
(DECLARE (LOCALVARS plst)
(SPECVARS file))
(MAP2C plst (CDR plst)
[FUNCTION (LAMBDA (sl val)
(DECLARE (LOCALVARS sl val))
(PROG ((size (NCHARS sl))
(minspaces 2)
(mintabs 5)
(tabsize 4)
over)
(DECLARE (LOCALVARS over tabsize mintabs minspaces size)
(SPECVARS file))
(SETQ over (ITIMES tabsize
(IMAX (IPLUS (IQUOTIENT (IPLUS size
(IDIFFERENCE
minspaces 1))
tabsize)
1)
mintabs)))
(* The following should print non-functions in some nice manner, but
.PPV doesn't do that. So, pending a better prettyprinter for that
purpose, we ignore the function/non-function distinction.
(COND ((AND (LISTP val) (ListFormat (OR (UA-GETPROP sl
(QUOTE Format)) (QUOTE FSingleton)))) (PRINTOUT file sl .TAB over .PPV
val T)) (T (PRINTOUT file sl .TAB over .PPF val T))))
(printout file sl .TAB over .PPF val T]
(FUNCTION CDDR])
(SELECTIVE-UNADVISE
[LAMBDA (fn when where what)
(* edited: "11-Mar-82 18:31" This function selectively removes some
bit of advice from an advised function, leaving the rest in place.
That actual morsel of advise is determined by the when, where and what
arguments passed above, corresponding to these parameters on ADVISE.
Modified so doesn't readvise if remaining advise is NIL.)
(DECLARE (LOCALVARS fn)
(SPECVARS when where what))
(PROG ((all-advise (GETPROP fn (QUOTE READVICE)))
un-advise remaining-advise)
(DECLARE (LOCALVARS all-advise un-advise remaining-advise))
[OR all-advise (PROGN (APPLY* (QUOTE UNADVISE)
fn)
(APPLY* (QUOTE READVISE)
fn)
(SETQ all-advise (GETPROP fn (QUOTE READVICE]
(APPLY* (QUOTE UNADVISE)
fn)
[SETQ un-advise (SUBSET all-advise (FUNCTION (LAMBDA (adv)
(DECLARE (LOCALVARS adv)
(SPECVARS what where when))
(AND (OR (NOT when)
(EQ when (CAR adv)))
(OR (NOT where)
(EQ where (CADR adv)))
(OR (NOT what)
(EQUAL what (CADDR adv]
(PUTPROP fn (QUOTE UNADVISED)
un-advise)
(SETQ remaining-advise (LDIFFERENCE all-advise un-advise))
(RETURN (COND
((CDR remaining-advise)
(PUTPROP fn (QUOTE READVICE)
remaining-advise)
(APPLY* (QUOTE READVISE)
fn))
(T (REMPROP fn (QUOTE READVICE))
NIL])
(SFVerifyRR
[LAMBDA (NewSpec OldSpec)
(* edited: "11-Mar-82 15:22" Verify Range Restrictions for Slot
Formats.)
(AND (OR (EQ (CAR NewSpec)
(CAR OldSpec))
(Warning "Unequal Slot Format Specs " NewSpec " and " OldSpec "."))
(OR (EQ (LENGTH NewSpec)
(LENGTH OldSpec))
(Warning "Unequal length Slot Format Specs " NewSpec " and " OldSpec "."))
(APPLY (FUNCTION AND)
(MAP2CAR (CDR NewSpec)
(CDR OldSpec)
(FUNCTION (LAMBDA (NewClause OldClause)
(DECLARE (LOCALVARS NewClause OldClause))
(APPLY* (COND
[(IsOk (GetValue (CAR NewClause)
(QUOTE
FnForVerifyingRangeRestriction)
(QUOTE (SAFESLOT]
(T (Warning (CAR NewClause)
" has no FnForVerifyingRangeRestriction.")
(FUNCTION NILL)))
NewClause OldClause])
(UpdateDepend
[LAMBDA (forms uThisUnit uThisSlot new modif why)
(* edited: "10-Mar-82 16:58")
(DECLARE (LOCALVARS modif new uThisUnit forms)
(SPECVARS why uThisSlot))
(PROG ((hold (ASSOC (QUOTE From)
why))
temp)
(DECLARE (LOCALVARS hold))
(RETURN
(COND
((MEMB (QUOTE -DEPENDENCIES)
why)
T)
((AND (MustComputep new)
(EQ (CAR modif)
(QUOTE OldVal))
(MustComputep (CDR modif))
(NOT (MEMB (QUOTE +DEPENDENCIES)
why)))
T)
(T
(* COND (hold (RPLACD hold (CONS Sl (CDR hold))))
(T (SETQ why (CONS (LIST (QUOTE From) Sl) why))))
(EVERY forms
(FUNCTION (LAMBDA (sl-fn)
(DECLARE (SPECVARS why uThisUnit sl-fn))
(SELECTQ
(-> sl-fn Operation)
(InvalidateAll (SETQ hold (EVAL (-> sl-fn Code)))
(COND
[(COND
((IGREATERP (LENGTH hold)
40)
(WRITELNTTY "There are some "
(LENGTH hold)
" units whose " uThisSlot
" must now be invalidated, "
"because of "
(-> sl-fn AffectedSlot))
(INTTYYNB "Shall I do it? "))
(T T))
(EVERY hold
(FUNCTION (LAMBDA (unT)
(DECLARE (LOCALVARS unT)
(SPECVARS uThisSlot
why sl-fn))
(InvalidateValue unT
(-> sl-fn
AffectedSlot)
uThisSlot why]
(T T)))
(Invalidate1 (InvalidateValue (EVAL (-> sl-fn Code))
(-> sl-fn AffectedSlot)
uThisSlot why))
(Invalidate0 T)
[InvalidateP
(EVERY [IsOk (GetValue (-> sl-fn AffectedSlot)
(QUOTE StoredAList)
(QUOTE (SAFESLOT (-COMPUTE
StoredAList]
(FUNCTION (LAMBDA (unT)
(DECLARE (LOCALVARS unT)
(SPECVARS uThisSlot why))
(SETQ unT (CAR unT))
(COND
((SOME unT (-> sl-fn Code))
(InvalidateValue unT (-> sl-fn AffectedSlot)
uThisSlot why))
(T T]
(Warning "Unable to understand " sl-fn ", in " (QUOTE
UpdateDepend)
"."])
)
(RPAQQ NEWADDITIONSVARS (ValidWhyValues))
(RPAQQ ValidWhyValues (-VERIFY -INVERSES -DEPENDENCIES -USE-OLD-VALUE +COMPUTE-INITIAL
FAST-PUT N-VALUES InSubUnit -CreateSubUnit -VERIFY-SLOT
-VERIFY-VALUE +DEPENDENCIES))
(DECLARE: DONTCOPY
(FILEMAP(NIL (600 12213 (CheckWhy 612 . 1488) (ComplexVV 1492 . 3324) (DI-Print 3328 .
3860) (DTVerifyRR 3864 . 4809) (DefaultInvalidateUnitFn 4813 . 5079) (FigureMSF
5083 . 5466) (InverseLIL 5470 . 5840) (KB-SUMMARY 5844 . 6171) (LOVerifyRR 6175
. 6431) (P-PLST 6435 . 7542) (SELECTIVE-UNADVISE 7546 . 9081) (SFVerifyRR 9085 .
9963) (UpdateDepend 9967 . 12210)))))
STOP